home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_FILEH.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-24  |  11KB  |  417 lines
  1. unit GS_FileH;
  2. {------------------------------------------------------------------------------
  3.                                   File Handler
  4.  
  5.        Copyright (c)  Richard F. Griffin
  6.  
  7.        20 February 1992
  8.  
  9.        102 Molded Stone Pl
  10.        Warner Robins, GA  31088
  11.  
  12.        -------------------------------------------------------------
  13.        This unit handles all untyped files.  Also provides file directory
  14.        search and selection.
  15.  
  16.        Since all calls come through here for untyped files, this is a point
  17.        to trap the calls in the future for shared file handling.
  18.  
  19.        Changes:
  20.  
  21.           19 Feb 92 - Deleted buffering to speed indexed retrievals.
  22.  
  23. ------------------------------------------------------------------------------}
  24.  
  25. interface
  26. {$d-}
  27.  
  28. uses
  29.    CRT,
  30.    Dos,
  31.    GS_Strng,
  32.    GS_Error;
  33.  
  34. var
  35.    GS_FileDrvTab      : array[0..127] of char;
  36.    GS_FileDrvCnt      : byte;
  37.  
  38.    BRCmd,
  39.    BWCmd,
  40.    IOAsk,
  41.    IORed,
  42.    IOWri,
  43.    IOPhy  : word;
  44.  
  45. Procedure GS_FileAssign(var dF : file; Fname : string);
  46. Procedure GS_FileClose(var dF : file);
  47. Procedure GS_FileErase(var dF : file);
  48. Function  GS_FileExists(var dF : file; Fname : string) : boolean;
  49. Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
  50.                        var RtnRslt : word);
  51. Procedure GS_FileRename(var dF : file; FName : string);
  52. Procedure GS_FileReset(var dF : file; len : longint);
  53. Procedure GS_FileRewrite(var dF : file; len : longint);
  54. Function  GS_FileSize(var dF : file) : longint;
  55. Procedure GS_FileTruncate(var dF : file; loc : longint);
  56. Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
  57.                        var RtnRslt : word);
  58. function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
  59.                                                                    : string;
  60.  
  61. implementation
  62.  
  63. uses
  64.    GS_Pick,
  65.    GS_Winfc;
  66.  
  67. type
  68.    BufrRec = record
  69.                 Size   : word;        {Size of buffer}
  70.                 CntByt : word;        {Bytes stores in buffer}
  71.                 Posn   : longint;     {Beginning byte of file in buffer}
  72.                 FPosn  : longint;     {Last byte read + 1 in buffer}
  73.                 BufPtr : Pointer;
  74.              end;
  75.  
  76. var
  77.    Bufr  : BufrRec;
  78.    dbfErr : integer;
  79.    Blok,
  80.    TPosS,
  81.    TPosE  : longint;
  82.    StrFil : string[80];
  83.    istrue : boolean;
  84.  
  85.    cdriv   : byte;
  86.    tdrv    : byte;
  87.    regs    : Registers;
  88.  
  89.    ShoWin  : GS_Wind_Objt;
  90.  
  91. Procedure GS_FileAssign(var dF : file; Fname : string);
  92. var
  93.    dFa    : FileRec absolute dF;
  94. begin
  95.    Assign(df, FName);
  96.    Bufr.Posn  := -1;
  97.    Bufr.FPosn := 0;
  98.    Bufr.CntByt := 0;
  99.    Bufr.Size  := 0;
  100.    Bufr.BufPtr := nil;
  101.    move(Bufr, dFa.UserData, sizeof(Bufr));
  102. end;
  103.  
  104. Procedure GS_FileClose(var dF : file);
  105. var
  106.    dFa    : FileRec absolute dF;
  107. begin
  108.    Close(df);
  109. end;
  110.  
  111. Procedure GS_FileErase(var dF : file);
  112. begin
  113.    Erase(df);
  114. end;
  115.  
  116. Function  GS_FileExists(var dF : file; Fname : string) : boolean;
  117. begin
  118.    if (FName <> '') then
  119.    begin
  120.       {$I-}
  121.       Assign(dF, FName);
  122.       Reset(dF);
  123.       Close(dF);
  124.       {$I+}
  125.       GS_FileExists := (IOResult = 0);
  126.    end else GS_FileExists := false;
  127. end;
  128.  
  129. Procedure GS_FileRead(var dF : file; blk : longint; var dat; len : longint;
  130.                       var RtnRslt : word);
  131. var
  132.    dFa    : FileRec absolute dF;
  133.    Result : word;
  134.    StrFil : string[80];
  135. begin
  136.    move(dFa.UserData, Bufr, sizeof(Bufr));
  137.    if blk = -1 then blk := succ(Bufr.Posn);
  138.    dbfErr := 0;
  139.    begin
  140.       (*$I-*) Seek(dF, blk); (*$I+*)
  141.       dbfErr := IOResult;
  142.    end;
  143.    IF dbfErr = 0 THEN               {If seek ok, read the record}
  144.    BEGIN
  145.       inc(BRCmd);
  146.       (*$I-*)
  147.       BlockRead(dF, dat, len, Result);
  148.       (*$I+*)
  149.       RtnRslt := Result;
  150.       dbfErr := IOResult;
  151.       if dbfErr = 0 then
  152.       begin
  153.          Bufr.Posn := blk + (len-1);
  154.          move(Bufr, dFa.UserData, sizeof(Bufr));
  155.       end;
  156.    end;
  157.    if dbfErr <> 0 then
  158.    begin
  159.       CnvAscToStr(dFa.Name,StrFil,64);
  160.       ShowError(dbfErr,StrFil);
  161.    end;
  162. end;
  163.  
  164. Procedure GS_FileRename(var dF : file; Fname : string);
  165. begin
  166.    Rename(df, FName);
  167. end;
  168.  
  169. Procedure GS_FileReset(var dF : file; len : longint);
  170. var
  171.    dFa    : FileRec absolute dF;
  172.    StrFil : string[80];
  173. begin
  174.    (*$I-*) Reset(dF, len); (*$I+*)
  175.    dbfErr := IOResult;
  176.    if dbfErr <> 0 then
  177.    begin
  178.       CnvAscToStr(dFa.Name,StrFil,64);
  179.       ShowError(dbfErr,StrFil);
  180.    end;
  181. end;
  182.  
  183. Procedure GS_FileRewrite(var dF : file; len : longint);
  184. var
  185.    dFa    : FileRec absolute dF;
  186.    StrFil : string[80];
  187. begin
  188.    (*$I-*) Rewrite(dF, len); (*$I+*)
  189.    dbfErr := IOResult;
  190.    if dbfErr <> 0 then
  191.    begin
  192.       CnvAscToStr(dFa.Name,StrFil,64);
  193.       ShowError(dbfErr,StrFil);
  194.    end;
  195. end;
  196.  
  197. Function GS_FileSize(var dF : file) : longint;
  198. begin
  199.    GS_FileSize := FileSize(df);
  200. end;
  201.  
  202.  
  203. Procedure GS_FileTruncate(var dF : file; loc : longint);
  204. var
  205.    dFa    : FileRec absolute dF;
  206. begin
  207.    move(dFa.UserData, Bufr, sizeof(Bufr));
  208.    if loc = -1 then loc := succ(Bufr.Posn);
  209.    dbfErr := 0;
  210.    (*$I-*) Seek(dF, loc); (*$I+*)
  211.    dbfErr := IOResult;
  212.    if dbfErr <> 0 then
  213.    begin
  214.       CnvAscToStr(dFa.Name,StrFil,64);
  215.       ShowError(dbfErr,StrFil);
  216.    end;
  217.    Truncate(df);
  218.    Bufr.Posn := loc;
  219.    move(Bufr, dFa.UserData, sizeof(Bufr));
  220. end;
  221.  
  222.  
  223. Procedure GS_FileWrite(var dF : file; blk : longint; var dat; len : longint;
  224.                        var RtnRslt : word);
  225. var
  226.    dFa    : FileRec absolute dF;
  227.    Result : word;
  228.    StrFil : string[80];
  229. begin
  230.    move(dFa.UserData, Bufr, sizeof(Bufr));
  231.    if blk = -1 then blk := succ(Bufr.Posn);
  232.    dbfErr := 0;
  233.    (*$I-*) Seek(dF, blk); (*$I+*)
  234.    dbfErr := IOResult;
  235.    IF dbfErr = 0 THEN               {If seek ok, read the record}
  236.    BEGIN
  237.       (*$I-*) BlockWrite(dF, dat, len, Result); (*$I+*)
  238.       RtnRslt := Result;
  239.       dbfErr := IOResult;
  240.       IF dbfErr = 0 THEN               {If seek ok, read the record}
  241.       BEGIN
  242.          Bufr.Posn := blk + (len-1);
  243.          move(Bufr, dFa.UserData, sizeof(Bufr));
  244.       end;
  245.    end;
  246.    if dbfErr <> 0 then
  247.    begin
  248.       CnvAscToStr(dFa.Name,StrFil,64);
  249.       ShowError(dbfErr,StrFil);
  250.    end;
  251. end;
  252.  
  253. function GS_FileFindFiles(pth, fname : string; LookElseWhere : boolean)
  254.                                                                   : string;
  255. var
  256.    DirInfo : SearchRec;
  257.    FilTabl : array[1..512] of string[12];
  258.    Labl    : string;
  259.    DirNow,
  260.    DirNam,
  261.    DirCur  : PathStr;
  262.    DSt     : DirStr;
  263.    NSt     : NameStr;
  264.    ESt     : ExtStr;
  265.    itms    : integer;
  266.    rfil    : integer;
  267.    rdir    : integer;
  268.    slct    : integer;
  269.    lctn    : integer;
  270.    wtx,
  271.    wbg,
  272.    wfg,
  273.    wti,
  274.    wbi     : byte;
  275.    wx1,
  276.    wy1,
  277.    wx2,
  278.    wy2     : integer;
  279.  
  280.   procedure MakeFileTable;
  281.   var
  282.      i : integer;
  283.      d : string;
  284.      v : char;
  285.      u : byte absolute v;
  286.      b : byte;
  287.    begin
  288.       itms := 0;
  289.       FindFirst(Labl, Archive, DirInfo);
  290.       while DosError = 0 do
  291.       begin
  292.          inc(itms);
  293.          FilTabl[itms] := DirInfo.Name;
  294.          FindNext(DirInfo);
  295.       end;
  296.       rfil := itms;
  297.       if itms > 0 then
  298.          GS_Pick_Item_Sort(FilTabl[1],sizeof(FilTabl[1]),itms,true);
  299.       if LookElseWhere then
  300.       begin
  301.          FindFirst('*.', Directory, DirInfo);
  302.          while DosError = 0 do
  303.          begin
  304.             if (DirInfo.Attr = directory) and (DirInfo.Name <> '.') then
  305.             begin
  306.                inc(itms);
  307.                for i := 1 to length(DirInfo.Name) do
  308.                begin
  309.                   v := DirInfo.Name[i];
  310.                   if v in ['A'..'Z'] then u := u + 32;
  311.                   DirInfo.Name[i] := v;
  312.                end;
  313.                FilTabl[itms] := DirInfo.Name+'\';
  314.             end;
  315.             FindNext(DirInfo);
  316.          end;
  317.          rdir := itms;
  318.          if itms-rfil > 0 then
  319.             GS_Pick_Item_Sort(FilTabl[succ(rfil)],sizeof(FilTabl[1]),
  320.                               itms-rfil,true);
  321.          for i := 0